Enigma Amiga Life 109/EnigmaAmiga109CD.iso/dalla rivista/amiga.free/sorgenti vari/wolfedit2 2.0.4 source.sit/WolfEdit2 2.0.4 Source/UMapPalette.p

Text File | 1996-07-28 | 14KB | 588 lines

unit UMapPalette;

interface
    uses
        UMapCellsView;

    type

        TMapPalette = object(TMapCellsView)
                procedure IMapPalette (itsMapList: TMapListDoc);
                function CurrentCell: Point;
                procedure SelectCell (cell: Point);
                procedure GetCurrentCodeAndMask (var code, mask: MapCell);
                procedure GetCodeAndMask (cell: Point; var code, mask: MapCell);
                function GetCode (cell: Point): MapCell;
                function GetMask (cell: Point): MapCell;
                function SelectByCommand (cmdNumber: integer): boolean;
                procedure SelectByExample (example: MapCell);
                procedure TMapPalette.SetupPaletteMenus (curEncounter: integer);
                procedure DrawCell (cell: Point; r: Rect; var hilite: boolean);
                override;
                function TMapPalette.GetCellForDrawing (cell: Point): MapCell;
                override;
                procedure ChangeCellHilite (cell: Point; hilite: boolean);
                override;
                procedure Click (var e: EventInfo);
                override;
                procedure SetSelectionRect (newSel: Rect);
                override;
                procedure ImagesChanged;
            end;

    procedure IUMapPalette;

implementation
    uses
        HexIO;

    const

        paletteWidth = 21;        {Number of columns in the palette.}
                                        {The number of rows is dynamic.}

        paletteWidthLess1 = paletteWidth - 1;

    {Item types for palette initialisation resources}

        generalItem = 0;
        wallItem = 1;
        objectItem = 2;

    type

    {The palette table contains an entry for each cell of the palette.}

        PaletteTableEntry = record
                encounter: integer;                {Encounter available in}
                cmdNumber: integer;                {Associated menu command}
            end;

        PaletteTableHandle = ^PaletteTablePtr;
        PaletteTablePtr = ^PaletteTable;
        PaletteTable = array[0..99, 0..paletteWidthLess1] of PaletteTableEntry;

    {Palette initialisation resource}

        SimplePALTItem = record
                code: integer;
                cmdNumber: integer;
            end;

        GeneralPALTItem = packed record
                wall, obj, dir: 0..255;
                wallMask, objMask, dirMask: 0..255;
                cmdNumber: integer;
            end;

        PALTHandle = ^PALTPtr;
        PALTPtr = ^PALTRecord;
        PALTRecord = record
                encounter: integer;
                case itemType : integer of
                    wallItem, objectItem: (
                            numSimpleItems: integer;
                            simpleItems: array[1..99] of SimplePALTItem;
                    );
                    generalItem: (
                            unused: integer;
                            numGeneralItems: integer;
                            generalItems: array[1..99] of GeneralPALTItem;
                    );
            end;

    {Table describing menu items which modify palette codes}

        TPaletteModifier = object
                fPMOD: PMODHandle;
                fState: integer;
                fNext: TPaletteModifier;
                procedure IPaletteModifier (pmod: PMODHandle);
                function TPaletteModifier.ModifyCell (var cell: MapCell): boolean;
                function TPaletteModifier.Yields (cell, example, mask: MapCell; var state: integer): boolean;
                procedure TPaletteModifier.SetupMenus (curEncounter: integer);
                function TPaletteModifier.DoMenuCommand (cmdNumber: integer): boolean;
            end;

    var

        gNumPaletteItems: integer;        {Number of occupied cells}
        gNumPaletteCells: integer;        {Total number of cells}
        gPaletteWidth: integer;                {Number of cells wide}
        gPaletteHeight: integer;            {Number of cells high}

        gMapPaletteCells: TMapCells;
        gMapPaletteMasks: TMapCells;
        gPaletteTable: PaletteTableHandle;
        gPalModList: TPaletteModifier;

{------------------------- Unit Initialisation ----------------------------}

    function MakeMapCell (wall, obj, flags: integer): MapCell;
    begin
        MakeMapCell.wall := wall;
        MakeMapCell.obj := obj;
        MakeMapCell.flags := flags;
        MakeMapCell.area := 0;
    end;

    procedure IUMapPalette;

        procedure ForEachPALT (procedure ProcessPALT (h: PALTHandle));
            var
                h: Handle;
                i: integer;
        begin
            i := 128;
            while true do begin
                    h := GetResource('PALT', i);
                    if h = nil then
                        exit(ForEachPALT);
                    ProcessPALT(PALTHandle(h));
                    ReleaseResource(h);
                    i := i + 1;
                end;
        end;

        function CountPaletteItems: integer;
            var
                n: integer;

            procedure CountPALTItems (palt: PALTHandle);
            begin
                case palt^^.itemType of
                    wallItem, objectItem:
                        n := n + palt^^.numSimpleItems;
                    generalItem:
                        n := n + palt^^.numGeneralItems;
                end;
            end;

        begin {CountPaletteItems}
            n := 0;
            ForEachPALT(CountPALTItems);
            CountPaletteItems := n;
        end;

        procedure InstallPaletteItems;
            var
                cell: Point;
                n: integer;
                enc: integer;

            procedure NextCell;
            begin
                cell.h := cell.h + 1;
                if cell.h = gPaletteWidth then begin
                        cell.h := 0;
                        cell.v := cell.v + 1;
                    end;
                n := n + 1;
            end;

            procedure InstallItem (wall, obj, flags, wallMask, objMask, flagsMask, cmdNum: integer);
            begin
                with gPaletteTable^^[cell.v, cell.h] do begin
                        encounter := enc;
                        cmdNumber := cmdNum;
                    end;
                gMapPaletteCells.SetCell(cell, MakeMapCell(wall, obj, flags));
                gMapPaletteMasks.SetCell(cell, MakeMapCell(wallMask, objMask, flagsMask));
                NextCell;
            end;

            procedure InstallSimpleItem (t: integer; var item: SimplePALTItem);
            begin
                case t of
                    wallItem:
                        InstallItem(item.code, 0, 0, $FF, $FF, 0, item.cmdNumber);
                    objectItem:
                        InstallItem(0, item.code, 0, $FF, $FF, 0, item.cmdNumber);
                end;
            end;

            procedure InstallGeneralItem (var item: GeneralPALTItem);
            begin
                with item do
                    InstallItem(wall, obj, dir, wallMask, objMask, dirMask, cmdNumber);
            end;

            procedure InstallItemsFromPALT (palt: PALTHandle);
                var
                    i, t: integer;
            begin
                enc := palt^^.encounter;
                t := palt^^.itemType;
                case t of
                    wallItem, objectItem:
                        for i := 1 to palt^^.numSimpleItems do
                            InstallSimpleItem(t, palt^^.simpleItems[i]);
                    generalItem:
                        for i := 1 to palt^^.numGeneralItems do
                            InstallGeneralItem(palt^^.generalItems[i]);
                end;
            end;

            procedure InstallEmptyItem;
            begin
                InstallItem(0, 0, 0, 0, 0, 0, 0);
            end;

        begin {InstallPaletteItems}
            SetPt(cell, 0, 0);
            n := 0;
            ForEachPALT(InstallItemsFromPALT);
            while n < gNumPaletteCells do
                InstallEmptyItem;
        end;

        procedure CalcPaletteSize;
        begin
            gNumPaletteItems := CountPaletteItems;
            gPaletteWidth := paletteWidth;
            gPaletteHeight := (gNumPaletteItems + gPaletteWidth - 1) div gPaletteWidth;
            gNumPaletteCells := gPaletteWidth * gPaletteHeight;
        end;

        procedure AllocatePaletteTable;
        begin
            gPaletteTable := PaletteTableHandle(NewHandle(gNumPaletteCells * sizeof(PaletteTableEntry)));
        end;

        procedure InitCellsAndMasks;
            var
                r: Rect;
        begin
            SetRect(r, 0, 0, gPaletteWidth, gPaletteHeight);
            new(gMapPaletteCells);
            gMapPaletteCells.IMapCells(r);
            new(gMapPaletteMasks);
            gMapPaletteMasks.IMapCells(r);
        end;

        procedure InitPalModList;
            var
                p: TPaletteModifier;
                i: integer;
        begin
            gPalModList := nil;
            for i := 1 to CountResources('PMOD') do begin
                    new(p);
                    p.IPaletteModifier(PMODHandle(GetIndResource('PMOD', i)));
                end;
        end;

    begin {IUMapPalette}
        CalcPaletteSize;
        AllocatePaletteTable;
        InitCellsAndMasks;
        InstallPaletteItems;
        InitPalModList;
    end;

{---------------------------- Utilities ---------------------------}

    procedure ForEachCell (procedure ProcessCell (c: Point));
        var
            row, col: integer;
            cell: Point;
    begin
        for row := 0 to gPaletteHeight - 1 do
            for col := 0 to gPaletteWidth - 1 do begin
                    SetPt(cell, col, row);
                    ProcessCell(cell);
                end;
    end;

    function GetCode (itemType: integer; var cell: MapCell): integer;
    begin
        case itemType of
            wallItem:
                GetCode := cell.wall;
            objectItem:
                GetCode := cell.obj;
        end;
    end;

    procedure SetCode (itemType: integer; var cell: MapCell; code: integer);
    begin
        case itemType of
            wallItem:
                cell.wall := code;
            objectItem:
                cell.obj := code;
        end;
    end;

{---------------------------- Palette Modifier ---------------------}

    procedure TPaletteModifier.IPaletteModifier (pmod: PMODHandle);
    begin
        fPMOD := pmod;
        fState := 0;
        fNext := gPalModList;
        gPalModList := self;
    end;

    function TPaletteModifier.ModifyCell (var cell: MapCell): boolean;
        var
            code: integer;
    begin
        with fPMOD^^ do begin
                code := GetCode(itemType, cell);
                if (code >= firstCode) & (code <= lastCode) then begin
                        SetCode(itemType, cell, code + fPMOD^^.entries[fState].offset);
                        ModifyCell := true;
                    end
                else
                    ModifyCell := false;
            end;
    end;

    function TPaletteModifier.Yields (cell, example, mask: MapCell; var state: integer): boolean;
        var
            cell2: MapCell;
            i, code: integer;
    begin
        cell2 := cell;
        with fPMOD^^ do begin
                code := GetCode(itemType, cell);
                for i := 0 to lastCmd - firstCmd do begin
                        if (code >= firstCode) & (code <= lastCode) then begin
                                SetCode(itemType, cell2, code + entries[i].offset);
                                if EqualCode(cell2, AndCode(example, mask)) then begin
                                        state := i;
                                        Yields := true;
                                        exit(Yields);
                                    end;
                            end;
                    end;
            end;
        Yields := false;
    end;

    procedure TPaletteModifier.SetupMenus (curEncounter: integer);
        var
            cmd: integer;
    begin
        with fPMOD^^ do begin
                for cmd := firstCmd to lastCmd do
                    if curEncounter >= entries[cmd - firstCmd].encounter then
                        EnableCmd(cmd);
                CheckCmd(firstCmd + fState, true);
            end;
    end;

    function TPaletteModifier.DoMenuCommand (cmdNumber: integer): boolean;
    begin
        with fPMOD^^ do
            if (cmdNumber >= firstCmd) & (cmdNumber <= lastCmd) then begin
                    fState := cmdNumber - firstCmd;
                    DoMenuCommand := true;
                end
            else
                DoMenuCommand := false;
    end;

    procedure ModifyCell (var cell: MapCell);
        var
            p: TPaletteModifier;
    begin
        p := gPalModList;
        while (p <> nil) & not p.ModifyCell(cell) do
            p := p.fNext;
    end;

    function ModifierYields (cell, example, mask: MapCell; var p: TPaletteModifier; var state: integer): boolean;
    begin
        p := gPalModList;
        while (p <> nil) & not p.Yields(cell, example, mask, state) do
            p := p.fNext;
        ModifierYields := p <> nil;
    end;

    procedure SetupModifierMenus (curEncounter: integer);
        var
            p: TPaletteModifier;
    begin
        p := gPalModList;
        while p <> nil do begin
                p.SetupMenus(curEncounter);
                p := p.fNext;
            end;
    end;

    function DoModifierCommand (cmdNumber: integer): boolean;
        var
            p: TPaletteModifier;
    begin
        p := gPalModList;
        while (p <> nil) & not p.DoMenuCommand(cmdNumber) do
            p := p.fNext;
        DoModifierCommand := p <> nil;
    end;

{------------------------ TMapPalette Methods ------------------------}

    procedure TMapPalette.IMapPalette (itsMapList: TMapListDoc);
    begin
        IMapCellsView(gMapPaletteCells, [], itsMapList);
        SetCellSize(fCellSize.h + 4, fCellSize.v + 4);
        SetSelection(0, 0, 1, 1);
    end;

    function TMapPalette.CurrentCell: Point;
    begin
        CurrentCell := fSelection.topLeft;
    end;

    procedure TMapPalette.SelectCell (cell: Point);
    begin
        SetSelection(cell.h, cell.v, cell.h + 1, cell.v + 1);
    end;

    procedure TMapPalette.GetCurrentCodeAndMask (var code, mask: MapCell);
    begin
        GetCodeAndMask(CurrentCell, code, mask);
        ModifyCell(code);
    end;

    procedure TMapPalette.GetCodeAndMask (cell: Point; var code, mask: MapCell);
    begin
        code := GetCode(cell);
        mask := GetMask(cell);
    end;

    function TMapPalette.GetCode (cell: Point): MapCell;
    begin
        GetCode := gMapPaletteCells.GetCell(cell);
    end;

    function TMapPalette.GetMask (cell: Point): MapCell;
    begin
        GetMask := gMapPaletteMasks.GetCell(cell);
    end;

    function TMapPalette.SelectByCommand (cmdNumber: integer): boolean;

        procedure TestTableEntry (cell: Point);
        begin
            if gPaletteTable^^[cell.v, cell.h].cmdNumber = cmdNumber then begin
                    SetSelection(cell.h, cell.v, cell.h + 1, cell.v + 1);
                    SelectByCommand := true;
                    exit(SelectByCommand);
                end;
        end;

    begin {TMapPalette.SelectByCommand}
        ForEachCell(TestTableEntry);
        SelectByCommand := DoModifierCommand(cmdNumber);
    end;

    procedure TMapPalette.SelectByExample (example: MapCell);

        procedure TestCell (cell: Point);
            var
                code, mask: MapCell;
                modifier: TPaletteModifier;
                state: integer;
        begin
            GetCodeAndMask(cell, code, mask);
            if ModifierYields(code, example, mask, modifier, state) then begin
                    SelectCell(cell);
                    modifier.fState := state;
                    exit(SelectByExample);
                end
            else if EqualCode(code, AndCode(example, mask)) then begin
                    SelectCell(cell);
                    exit(SelectByExample);
                end;
        end;

    begin {TMapPalette.SelectByExample}
        ForEachCell(TestCell);
    end;

    procedure TMapPalette.SetupPaletteMenus (curEncounter: integer);

        procedure SetupForCell (cell: Point);
            var
                cmd: integer;
        begin
            if fMapList.ItemAvailable(GetCode(cell)) then
                with gPaletteTable^^[cell.v, cell.h] do
                    if cmdNumber <> 0 then begin
                            EnableCmd(cmdNumber);
                            if EqualPt(cell, fSelection.topLeft) then
                                CheckCmd(cmdNumber, true);
                        end;
        end;

    begin {SetupPaletteMenus}
        ForEachCell(SetupForCell);
        SetupModifierMenus(curEncounter);
    end;

    procedure TMapPalette.DrawCell (cell: Point; r: Rect; var hilite: boolean);
        var
            ri: Rect;
    begin
        EraseRect(r);
        if fMapList.ItemAvailable(GetCode(cell)) then begin
                ri := r;
                InsetRect(ri, 2, 2);
                inherited DrawCell(cell, ri, hilite);
            end
        else begin
                PenNormal;
                ForeColor(blackColor);
                MoveTo(r.left, r.top);
                LineTo(r.right - 1, r.bottom - 1);
                MoveTo(r.right - 1, r.top);
                LineTo(r.left, r.bottom - 1);
            end;
    end;

    function TMapPalette.GetCellForDrawing (cell: Point): MapCell;
        var
            code: MapCell;
    begin
        code := inherited GetCellForDrawing(cell);
{$IFC FALSE}
        ModifyCell(code);
{$ENDC}
        GetCellForDrawing := code;
    end;

    procedure TMapPalette.ChangeCellHilite (cell: Point; hilite: boolean);
        var
            r: Rect;
    begin
        Focus;
        CellToRect(cell, r);
        PenNormal;
        PenSize(2, 2);
        PenMode(patXor);
        FrameRect(r);
    end;

    procedure TMapPalette.Click (var e: EventInfo);
    begin
        inherited Click(e);
        Update;
    end;

    procedure TMapPalette.SetSelectionRect (newSel: Rect);
    begin
        if fMapList.ItemAvailable(GetCode(newSel.topLeft)) then
            inherited SetSelectionRect(newSel);
    end;

    procedure TMapPalette.ImagesChanged;
    begin
        Invalidate;
        if not fMapList.ItemAvailable(GetCode(fSelection.topLeft)) then
            SetSelection(0, 0, 1, 1);
    end;

end.